home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / defstruc.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-07-20  |  35.9 KB  |  824 lines
  1. ; Sources fⁿr DEFSTRUCT Macro.
  2. ; Bruno Haible 13.04.1988, 22.08.1988
  3. ; umgeschrieben am 02.09.1989 von Bruno Haible
  4.  
  5. (in-package "SYSTEM")
  6.  
  7. (defsetf %structure-ref %structure-store)
  8.  
  9. #| ErklΣrung der auftretenden Datentypen:
  10.  
  11.    (get name 'DEFSTRUCT-DESCRIPTION) =
  12.      #(names type keyword-constructor slotlist defaultfun0 defaultfun1 ...)
  13.  
  14.    names ist eine Codierung der INCLUDE-Verschachtelung fⁿr Structure name:
  15.    names = (name_1 ... name_i-1 name_i) wobei name=name_1,
  16.      name_1 enthΣlt name_2, ..., name_i-1 enthΣlt name_i.
  17.  
  18.    type (wenn der Typ der ganzen Structure gemeint ist):
  19.       = T                      Abspeicherung als normale Structure
  20.       = LIST                   Abspeicherung als Liste
  21.       = VECTOR                 Abspeicherung als (simple-)Vector
  22.       = (VECTOR element-type)  Abspeicherung als Vector mit Element-Typ
  23.  
  24.    keyword-constructor = NIL oder der Name des Keyword-Constructor
  25.  
  26.    slotlist ist eine gepackte Beschreibung der einzelnen slots einer Structure:
  27.    slotlist = ({slot}*)
  28.    slot = #(name initargs offset initer default type readonly)
  29.    wobei name der Slotname ist,
  30.               (NIL fⁿr den Slot, in dem der Structure-Name steht)
  31.          default der Defaultwert ist:
  32.               entweder eine Konstante, die zum Defaultwert evaluiert,
  33.               oder eine Form (ein Symbol oder eine Liste (SVREF ...)), die
  34.               bei Auswertung in einem beliebigen Environment eine Funktion
  35.               liefert, die bei Aufruf den Defaultwert liefert.
  36.          type der deklarierte Type fⁿr diesen Slot ist,
  37.          readonly = NIL oder = T angibt, ob dieser Slot readonly ist, d.h.
  38.               nach dem Aufbau der Structure nicht mehr mit (setf ...)
  39.               verΣndert werden kann.
  40.    Bei type = T belegt der Structure-Name den Slot 0, wird aber nicht in der
  41.      slotlist aufgefⁿhrt, da zu seiner Initialisierung nichts zu tun ist.
  42.  
  43. |#
  44.  
  45. (defun make-ds-slot (name initargs offset initer default type readonly)
  46.   (vector name initargs offset initer default type readonly)
  47. )
  48. (proclaim '(inline ds-slot-name))
  49. (defun ds-slot-name (slot) (svref slot 0))
  50. ;(defun ds-slot-initargs (slot) (svref slot 1)) ; only used in clos.lsp
  51. (defmacro ds-slot-offset (slot) `(svref ,slot 2))
  52. (defun ds-slot-initer (slot) (svref slot 3)) ; only used in clos.lsp
  53. (defmacro ds-slot-default (slot) `(svref ,slot 4))
  54. (defmacro ds-slot-type (slot) `(svref ,slot 5))
  55. (defmacro ds-slot-readonly (slot) `(svref ,slot 6))
  56. (defun copy-ds-slot (slot) (sys::%copy-simple-vector slot))
  57.  
  58. #| (ds-symbol-or-error x) liefert eine Fehlermeldung, falls x kein Symbol ist.
  59. |#
  60. (defun ds-symbol-or-error (x)
  61.   (unless (symbolp x)
  62.     (error-of-type 'program-error
  63.       (DEUTSCH "~S: Das ist kein Symbol: ~S"
  64.        ENGLISH "~S: this is not a symbol: ~S"
  65.        FRANCAIS "~S : Ceci n'est pas un symbole: ~S")
  66.       'defstruct x
  67. ) ) )
  68.  
  69. #| Hilfsfunktion fⁿr beide Konstruktoren:
  70.    (ds-arg-default arg slot)
  71.    liefert zu einem Argument arg (Teil einer Argumentliste) den Teil der
  72.    Argumentliste, der dieses Argument mit dem Default fⁿr slot bindet.
  73. |#
  74.  
  75. (defun ds-arg-default (arg slot)
  76.   (let ((default (ds-slot-default slot)))
  77.     ; Default ist entweder Konstante oder Funktion oder Symbol
  78.     (if (constantp default)
  79.       (if (null default) arg `(,arg ,default))
  80.       `(,arg (SYS::%FUNCALL ,default))
  81. ) ) )
  82.  
  83. #| Hilfsfunktion fⁿr beide Konstruktoren:
  84.    (ds-make-constructor-body type name names size slotlist)
  85.    liefert den Ausdruck, der eine Structure vom vorgegebenen Typ
  86.    kreiert und fⁿllt.
  87. |#
  88. (defun ds-make-constructor-body (type name names size slotlist)
  89.   (if (and (eq type 'VECTOR)
  90.            (do ((slotlistr slotlist (cdr slotlistr))
  91.                 (index 0 (1+ index)))
  92.                ((null slotlistr) t)
  93.              (unless (eq (ds-slot-offset (car slotlistr)) index) (return nil))
  94.       )    )
  95.     ; optimize the usual case
  96.     `(VECTOR ,@(mapcar #'(lambda (slot)
  97.                            (if (ds-slot-name slot)
  98.                              `(THE ,(ds-slot-type slot) ,(ds-slot-name slot))
  99.                              `(QUOTE ,(ds-slot-default slot))
  100.                          ) )
  101.                        slotlist
  102.                )
  103.      )
  104.     `(LET ((OBJECT
  105.              ,(cond ((eq type 'T) `(%MAKE-STRUCTURE ,names ,size))
  106.                     ((eq type 'LIST) `(MAKE-LIST ,size))
  107.                     ((consp type) `(MAKE-ARRAY ,size :ELEMENT-TYPE ',(second type)))
  108.                     (t `(MAKE-ARRAY ,size))
  109.               )
  110.           ))
  111.        ,@(mapcar
  112.            #'(lambda (slot &aux (offset (ds-slot-offset slot)))
  113.                `(SETF
  114.                   ,(cond ((eq type 'T)
  115.                           `(%STRUCTURE-REF ',name OBJECT ,offset) )
  116.                          ((eq type 'LIST)
  117.                           `(NTH ,offset OBJECT) )
  118.                          ((eq type 'VECTOR)
  119.                           `(SVREF OBJECT ,offset) )
  120.                          (t `(AREF OBJECT ,offset) )
  121.                    )
  122.                   ,(if (ds-slot-name slot)
  123.                      `(THE ,(ds-slot-type slot) ,(ds-slot-name slot))
  124.                      `(QUOTE ,(ds-slot-default slot))
  125.                 )  )
  126.              )
  127.            slotlist
  128.          )
  129.        OBJECT
  130.      )
  131. ) )
  132.  
  133. #| Hilfsfunktion fⁿr ds-make-boa-constructor:
  134.  
  135.    (ds-arg-with-default arg slotlist)
  136.    liefert zu einem Argument arg (Teil einer Argumentliste) den Teil der
  137.    Argumentliste, der dieses Argument mit dem richtigen Defaultwert bindet.
  138. |#
  139.  
  140. (defun ds-arg-with-default (arg slotlist)
  141.   (if (listp arg)
  142.     ; Defaultwert ist bereits mitgegeben
  143.     arg
  144.     ; nur ein Symbol
  145.     (let ((slot (find arg slotlist :key #'ds-slot-name :test #'eq)))
  146.       (if slot
  147.         ; Slot gefunden -> dessen Defaultwert nehmen
  148.         (ds-arg-default arg slot)
  149.         ; Slot nicht gefunden, kein Defaultwert
  150.         arg
  151. ) ) ) )
  152.  
  153. #| (ds-make-boa-constructor descriptor type name names size slotlist)
  154.    liefert die Form, die den BOA-Konstrukor definiert.
  155. |#
  156. (defun ds-make-boa-constructor (descriptor type name names size slotlist)
  157.   (let ((constructorname (first descriptor))
  158.         (arglist (second descriptor)))
  159.     ; auf &KEY und &ALLOW-OTHER-KEYS testen:
  160.     (let ((keying (or (member '&KEY arglist :test #'eq)
  161.                       (member '&ALLOW-OTHER-KEYS arglist :test #'eq)
  162.          ))       )
  163.       (when keying
  164.         (error-of-type 'program-error
  165.           (DEUTSCH "~S ~S: Die Argumentliste fⁿr eine keywordfreie Konstruktorfunktion ~S darf kein ~S enthalten: ~S"
  166.            ENGLISH "~S ~S: the argument list for the BOA contructor ~S must not contain ~S: ~S"
  167.            FRANCAIS "~S ~S : La liste d'arguments pour un constructeur ~S libre de mot-clΘs ne peux pas contenir ~S: ~S")
  168.           'defstruct name constructorname (car keying) arglist
  169.     ) ) )
  170.     ; angegebene Argumente sammeln:
  171.     (let* ((argnames
  172.              (let ((L nil))
  173.                (dolist (arg arglist)
  174.                  (unless (member arg lambda-list-keywords :test #'eq)
  175.                    (push (if (listp arg) (first arg) arg) L)
  176.                ) )
  177.                (nreverse L)
  178.            ) )
  179.            ; argnames ist die Liste aller bereits in der Paramterliste mit
  180.            ; Werten versehenen Argumente.
  181.            (new-arglist ; neue Argumentliste
  182.              `(; required args:
  183.                ,@(do ((arglistr arglist (cdr arglistr))
  184.                       (arg)
  185.                       (required-args nil))
  186.                      ((or (endp arglistr)
  187.                           (member (setq arg (car arglistr)) lambda-list-keywords :test #'eq)
  188.                       )
  189.                       (nreverse required-args)
  190.                      )
  191.                    (push arg required-args)
  192.                  )
  193.                ; optional args:
  194.                ,@(do ((arglistr (cdr (member '&optional arglist :test #'eq)) (cdr arglistr))
  195.                       (arg)
  196.                       (optionals nil))
  197.                      ((or (endp arglistr)
  198.                           (member (setq arg (car arglistr)) lambda-list-keywords :test #'eq)
  199.                       )
  200.                       (if (null optionals) nil (cons '&optional (nreverse optionals)))
  201.                      )
  202.                    (push (ds-arg-with-default arg slotlist) optionals)
  203.                  )
  204.                ; rest arg:
  205.                ,@(let ((arglistr (member '&rest arglist :test #'eq)))
  206.                    (if arglistr `(&rest ,(second arglistr)) '())
  207.                  )
  208.                ; aux args:
  209.                &aux
  210.                ,@(do ((aux-args-r (cdr (member '&aux arglist :test #'eq)) (cdr aux-args-r))
  211.                       (aux-arg)
  212.                       (new-aux-args nil))
  213.                      ((or (null aux-args-r)
  214.                           (member (setq aux-arg (car aux-args-r)) lambda-list-keywords :test #'eq)
  215.                       )
  216.                       (nreverse new-aux-args)
  217.                      )
  218.                    (push (ds-arg-with-default aux-arg slotlist) new-aux-args)
  219.                  )
  220.                ,@(let ((slotinitlist nil))
  221.                    (dolist (slot slotlist)
  222.                      (when (ds-slot-name slot)
  223.                        (unless (member (ds-slot-name slot) argnames :test #'eq)
  224.                          (push (ds-arg-with-default (ds-slot-name slot) slotlist) slotinitlist)
  225.                    ) ) )
  226.                    (nreverse slotinitlist)
  227.               )  )
  228.           ))
  229.       `(DEFUN ,constructorname ,new-arglist
  230.          ,(ds-make-constructor-body type name names size slotlist)
  231.        )
  232. ) ) )
  233.  
  234. #| (ds-make-keyword-constructor descriptor type name names size slotlist)
  235.    liefert die Form, die den Keyword-Konstruktor definiert.
  236. |#
  237. (defun ds-make-keyword-constructor (descriptor type name names size slotlist)
  238.   `(DEFUN ,descriptor
  239.      (&KEY
  240.       ,@(mapcap
  241.           #'(lambda (slot)
  242.               (if (ds-slot-name slot)
  243.                 (list (ds-arg-default (ds-slot-name slot) slot))
  244.                 '()
  245.             ) )
  246.           slotlist
  247.      )  )
  248.      ,(ds-make-constructor-body type name names size slotlist)
  249. )  )
  250.  
  251. #| (ds-make-pred predname type name name-offset)
  252.    liefert die Form, die das TyptestprΣdikat fⁿr die Structure name kreiert.
  253.    Dabei ist:
  254.    type         der Typ der Structure,
  255.    name         der Name der Structure,
  256.    predname     der Name des TyptestprΣdikats,
  257.    name-offset  (nur bei type /= T ma▀geblich)
  258.                 die Stelle, an der der Name abgespeichert wird.
  259. |#
  260. (defun ds-make-pred (predname type name name-offset)
  261.   `(,@(if (eq type 'T) `((PROCLAIM '(INLINE ,predname))) '())
  262.     (DEFUN ,predname (OBJECT)
  263.       ,(if (eq type 'T)
  264.          `(%STRUCTURE-TYPE-P ',name OBJECT)
  265.          (if (eq type 'LIST)
  266.            `(AND (CONSP OBJECT)
  267.                  ,@(if (eql name-offset 0)
  268.                      `((EQ (CAR OBJECT) ',name))
  269.                      `((> (LENGTH OBJECT) ,name-offset)
  270.                        (EQ (NTH ,name-offset OBJECT) ',name)
  271.                       )
  272.             )      )
  273.            `(AND (SIMPLE-VECTOR-P OBJECT)
  274.                  (> (LENGTH OBJECT) ,name-offset)
  275.                  (EQ (SVREF OBJECT ,name-offset) ',name)
  276.             )
  277.        ) )
  278.    ))
  279. )
  280.  
  281. (defun ds-make-copier (copiername name type)
  282.   (declare (ignore name))
  283.   `(,@(if (or (eq type 'T) (eq type 'LIST))
  284.         `((PROCLAIM '(INLINE ,copiername)))
  285.         '()
  286.       )
  287.     (DEFUN ,copiername (STRUCTURE)
  288.       ,(if (eq type 'T)
  289.          '(%COPY-STRUCTURE STRUCTURE)
  290.          (if (eq type 'LIST)
  291.            '(COPY-LIST STRUCTURE)
  292.            (if (consp type)
  293.              `(LET* ((OBJ-LENGTH (ARRAY-TOTAL-SIZE STRUCTURE))
  294.                      (OBJECT (MAKE-ARRAY OBJ-LENGTH :ELEMENT-TYPE (QUOTE ,(second type))))
  295.                     )
  296.                 (DOTIMES (I OBJ-LENGTH OBJECT)
  297.                   (SETF (AREF OBJECT I) (AREF STRUCTURE I))
  298.               ) )
  299.              '(%COPY-SIMPLE-VECTOR STRUCTURE)
  300.        ) ) )
  301. )  ))
  302.  
  303. (defun ds-make-accessors (name type concname slotlist)
  304.   (mapcap
  305.     #'(lambda (slot)
  306.         (if (ds-slot-name slot)
  307.           (let ((accessorname (concat-pnames concname (ds-slot-name slot)))
  308.                 (offset (ds-slot-offset slot))
  309.                 (slottype (ds-slot-type slot)))
  310.             `((PROCLAIM '(FUNCTION ,accessorname (,name) ,slottype))
  311.               (PROCLAIM '(INLINE ,accessorname))
  312.               (DEFUN ,accessorname (OBJECT)
  313.                 (THE ,slottype
  314.                   ,(if (eq type 'T)
  315.                      `(%STRUCTURE-REF ',name OBJECT ,offset)
  316.                      (if (eq type 'LIST)
  317.                        `(NTH ,offset OBJECT)
  318.                        (if (consp type)
  319.                          `(AREF OBJECT ,offset)
  320.                          `(SVREF OBJECT ,offset)
  321.              )) )  ) ) )
  322.           )
  323.           '()
  324.       ) )
  325.     slotlist
  326. ) )
  327.  
  328. (defun ds-make-defsetfs (name type concname slotlist)
  329.   (mapcap
  330.     #'(lambda (slot)
  331.         (if (and (ds-slot-name slot) (not (ds-slot-readonly slot)))
  332.           (let ((accessorname (concat-pnames concname (ds-slot-name slot)))
  333.                 (offset (ds-slot-offset slot))
  334.                 (slottype (ds-slot-type slot)))
  335.             `((DEFSETF ,accessorname (STRUCT) (VALUE)
  336.                 ,(if (eq type 'T)
  337.                    `(LIST '%STRUCTURE-STORE '',name
  338.                       STRUCT
  339.                       ,offset
  340.                       ,(if (eq 'T slottype)
  341.                          `VALUE
  342.                          `(LIST 'THE ',slottype VALUE)
  343.                     )  )
  344.                    (if (eq type 'LIST)
  345.                      `(LIST 'SETF (LIST 'NTH ,offset STRUCT) VALUE)
  346.                      (if (consp type)
  347.                        `(LIST 'SETF (LIST 'AREF STRUCT ,offset) VALUE)
  348.                        `(LIST 'SETF (LIST 'SVREF STRUCT ,offset) VALUE)
  349.              ))  ) ) )
  350.       ) ) )
  351.     slotlist
  352. ) )
  353.  
  354. ; Ein Hook fⁿr CLOS
  355. (defun clos::define-structure-class (name) (declare (ignore name)) ) ; vorlΣufig
  356.  
  357. (defmacro defstruct (name-and-options . docstring-and-slotargs)
  358.   (let ((name                              name-and-options)
  359.         (options                           nil)
  360.         (conc-name-option                  t)
  361.         (constructor-option-list           nil)
  362.         (keyword-constructor               nil)
  363.         (copier-option                     t)
  364.         (predicate-option                  0)
  365.         (include-option                    nil)
  366.          names
  367.          namesform
  368.         (namesbinding                      nil)
  369.         (print-function-option             nil)
  370.         (type-option                       t)
  371.         (named-option                      0)
  372.         (initial-offset-option             0)
  373.         (initial-offset                    0)
  374.         (docstring                         nil)
  375.         (slotargs                          docstring-and-slotargs)
  376.          size
  377.         (include-skip                      0)
  378.         (inherited-slot-count              0)
  379.         (slotlist                          nil)
  380.         (slotdefaultvars                   nil)
  381.         (slotdefaultfuns                   nil)
  382.          constructor-forms                      )
  383.     ;; name-and-options ⁿberprⁿfen:
  384.     (when (listp name-and-options)
  385.       (setq name (first name-and-options))
  386.       (setq options (rest name-and-options))
  387.     ) ; andernfalls sind name und options schon korrekt.
  388.     (unless (and (symbolp name) (not (keywordp name)))
  389.       (error-of-type 'program-error
  390.         (DEUTSCH "~S: Falsche Syntax fⁿr Name und Optionen: ~S"
  391.          ENGLISH "~S: invalid syntax for name and options: ~S"
  392.          FRANCAIS "~S : Mauvaise syntaxe pour un nom et des options: ~S")
  393.         'defstruct name-and-options
  394.     ) )
  395.     ; name ist ein Symbol, options die Liste der Optionen.
  396.     ;; Abarbeitung der Optionen:
  397.     (dolist (option options)
  398.       (when (keywordp option) (setq option (list option))) ; Option ohne Argumente
  399.       (if (listp option)
  400.         (if (keywordp (car option))
  401.           (case (first option)
  402.             (:CONC-NAME
  403.                (setq conc-name-option (or (second option) ""))
  404.             )
  405.             (:CONSTRUCTOR
  406.                (if (atom (cdr option))
  407.                  ; Default-Keyword-Constructor
  408.                  (push (concat-pnames "MAKE-" name) constructor-option-list)
  409.                  (let ((arg (second option)))
  410.                    (ds-symbol-or-error arg)
  411.                    (push
  412.                      (if (atom (cddr option))
  413.                        arg ; Keyword-Constructor
  414.                        (if (not (listp (third option)))
  415.                          (error-of-type 'program-error
  416.                            (DEUTSCH "~S ~S: Argumentliste mu▀ eine Liste sein: ~S"
  417.                             ENGLISH "~S ~S: argument list should be a list: ~S"
  418.                             FRANCAIS "~S ~S : La liste d'arguments doit Ωtre une liste: ~S")
  419.                            'defstruct name (third option)
  420.                          )
  421.                          (rest option) ; BOA-Constructor
  422.                      ) )
  423.                      constructor-option-list
  424.             )  ) ) )
  425.             (:COPIER
  426.                (when (consp (cdr option))
  427.                  (let ((arg (second option)))
  428.                    (ds-symbol-or-error arg)
  429.                    (setq copier-option arg)
  430.             )  ) )
  431.             (:PREDICATE
  432.                (when (consp (cdr option))
  433.                  (let ((arg (second option)))
  434.                    (ds-symbol-or-error arg)
  435.                    (setq predicate-option arg)
  436.             )  ) )
  437.             ((:INCLUDE :INHERIT)
  438.                (if (null include-option)
  439.                  (setq include-option option)
  440.                  (error-of-type 'program-error
  441.                    (DEUTSCH "~S ~S: Es darf nur ein :INCLUDE-Argument geben: ~S"
  442.                     ENGLISH "~S ~S: At most one :INCLUDE argument may be specified: ~S"
  443.                     FRANCAIS "~S ~S : Il ne peut y avoir qu'un argument :INCLUDE: ~S")
  444.                    'defstruct name options
  445.             )  ) )
  446.             (:PRINT-FUNCTION
  447.                (let ((arg (second option)))
  448.                  (when (and (consp arg) (eq (first arg) 'FUNCTION))
  449.                    (warn (DEUTSCH "~S: Bei :PRINT-FUNCTION ist FUNCTION bereits implizit.~@
  450.                                    Verwende daher ~S statt ~S."
  451.                           ENGLISH "~S: Use of :PRINT-FUNCTION implicitly applies FUNCTION.~@
  452.                                    Therefore using ~S instead of ~S."
  453.                           FRANCAIS "~S : FUNCTION est dΘjα implicite avec :PRINT-FUNCTION.~@
  454.                                     C'est pourquoi ~S est utilisΘ au lieu de ~S.")
  455.                          'defstruct (second arg) arg
  456.                    )
  457.                    (setq arg (second arg))
  458.                  )
  459.                  (setq print-function-option
  460.                    (if (symbolp arg)
  461.                      ; ein Ausdruck, der eine eventuelle lokale Definition
  462.                      ; von arg mitberⁿcksichtigt, aber nicht erfordert:
  463.                      `(FUNCTION ,(concat-pnames name "-PRINT-FUNCTION")
  464.                         (LAMBDA (STRUCT STREAM DEPTH)
  465.                           (,arg STRUCT STREAM DEPTH)
  466.                       ) )
  467.                      `#',arg
  468.             )  ) ) )
  469.             (:TYPE (setq type-option (second option)))
  470.             (:NAMED (setq named-option t))
  471.             (:INITIAL-OFFSET (setq initial-offset-option (or (second option) 0)))
  472.             (T (error-of-type 'program-error
  473.                  (DEUTSCH "~S ~S: Die Option ~S gibt es nicht."
  474.                   ENGLISH "~S ~S: unknown option ~S"
  475.                   FRANCAIS "~S ~S : Option ~S non reconnue.")
  476.                  'defstruct name (first option)
  477.           ) )  )
  478.           (error-of-type 'program-error
  479.             (DEUTSCH "~S ~S: Falsche Syntax in ~S-Option: ~S"
  480.              ENGLISH "~S ~S: invalid syntax in ~S option: ~S"
  481.              FRANCAIS "~S ~S : Mauvaise syntaxe dans l'option ~S: ~S")
  482.             'defstruct name 'defstruct option
  483.         ) )
  484.         (error-of-type 'program-error
  485.           (DEUTSCH "~S ~S: Das ist keine ~S-Option: ~S"
  486.            ENGLISH "~S ~S: not a ~S option: ~S"
  487.            FRANCAIS "~S ~S : Ceci n'est pas une option ~S: ~S")
  488.           'defstruct name 'defstruct option
  489.     ) ) )
  490.     ; conc-name-option ist entweder T oder "" oder das :CONC-NAME-Argument.
  491.     ; constructor-option-list ist eine Liste aller :CONSTRUCTOR-Argumente,
  492.     ;   jeweils in der Form  symbol  oder  (symbol arglist . ...).
  493.     ; copier-option ist entweder T oder das :COPIER-Argument.
  494.     ; predicate-option ist entweder 0 oder das :PREDICATE-Argument.
  495.     ; include-option ist entweder NIL oder die gesamte
  496.     ;   :INCLUDE/:INHERIT-Option.
  497.     ; print-function-option ist NIL oder eine Form, die die Print-Function
  498.     ;   liefert.
  499.     ; type-option ist entweder T oder das :TYPE-Argument.
  500.     ; named-option ist entweder 0 oder T.
  501.     ; initial-offset-option ist entweder 0 oder das :INITIAL-OFFSET-Argument.
  502.     ;; ▄berprⁿfung der Optionen:
  503.     (setq named-option (or (eq type-option 'T) (eq named-option 'T)))
  504.     ; named-option (NIL oder T) gibt an, ob der Name in der Structure steckt.
  505.     (if named-option
  506.       (when (eql predicate-option 0)
  507.         (setq predicate-option (concat-pnames name "-P")) ; Defaultname
  508.       )
  509.       (unless (or (eql predicate-option 0) (eq predicate-option 'NIL))
  510.         (error-of-type 'program-error
  511.           (DEUTSCH "~S ~S: Bei unbenannten Structures kann es kein :PREDICATE geben."
  512.            ENGLISH "~S ~S: There is no :PREDICATE on unnamed structures."
  513.            FRANCAIS "~S ~S : Il ne peut pas y avoir de :PREDICATE avec des structures anonymes.")
  514.           'defstruct name
  515.     ) ) )
  516.     ; predicate-option ist
  517.     ;   bei named-option=T: entweder NIL oder der Name des TyptestprΣdikats,
  518.     ;   bei named-option=NIL bedeutungslos.
  519.     (if (eq conc-name-option 'T)
  520.       (setq conc-name-option (string-concat (string name) "-"))
  521.     )
  522.     ; conc-name-option ist der Namensprefix.
  523.     (if (null constructor-option-list)
  524.       (setq constructor-option-list (list (concat-pnames "MAKE-" name)))
  525.       (setq constructor-option-list (remove 'NIL constructor-option-list))
  526.     )
  527.     ; constructor-option-list ist eine Liste aller zu kreierenden Konstruktoren,
  528.     ;   jeweils in der Form  symbol  oder  (symbol arglist . ...).
  529.     (if (eq copier-option 'T)
  530.       (setq copier-option (concat-pnames "COPY-" name))
  531.     )
  532.     ; copier-option ist entweder NIL oder der Name der Kopierfunktion.
  533.     (unless (or (eq type-option 'T)
  534.                 (eq type-option 'VECTOR)
  535.                 (eq type-option 'LIST)
  536.                 (and (consp type-option) (eq (first type-option) 'VECTOR))
  537.             )
  538.       (error-of-type 'program-error
  539.         (DEUTSCH "~S ~S: UnzulΣssige :TYPE-Option ~S"
  540.          ENGLISH "~S ~S: invalid :TYPE option ~S"
  541.          FRANCAIS "~S ~S : Option :TYPE inadmissible: ~S")
  542.         'defstruct name type-option
  543.     ) )
  544.     ; type-option ist entweder T oder LIST oder VECTOR oder (VECTOR ...)
  545.     (unless (and (integerp initial-offset-option) (>= initial-offset-option 0))
  546.       (error-of-type 'program-error
  547.         (DEUTSCH "~S ~S: Der :INITIAL-OFFSET mu▀ ein Integer >=0 sein, nicht ~S"
  548.          ENGLISH "~S ~S: The :INITIAL-OFFSET must be a nonnegative integer, not ~S"
  549.          FRANCAIS "~S ~S : :INITIAL-OFFSET doit Ωtre un entier positif ou zΘro et non ~S")
  550.         'defstruct name initial-offset-option
  551.     ) )
  552.     ; initial-offset-option ist ein Integer >=0.
  553.     (when (and (plusp initial-offset-option) (eq type-option 'T))
  554.       (error-of-type 'program-error
  555.         (DEUTSCH "~S ~S: :INITIAL-OFFSET darf nur zusammen mit :TYPE angegeben werden: ~S"
  556.          ENGLISH "~S ~S: :INITIAL-OFFSET must not be specified without :TYPE : ~S"
  557.          FRANCAIS "~S ~S : :INITIAL-OFFSET ne peut Ωtre prΘcisΘ qu'ensemble avec :TYPE: ~S")
  558.         'defstruct name options
  559.     ) )
  560.     ; Bei type-option=T ist initial-offset-option=0.
  561.     (when (eq type-option 'T) (setq include-skip 1))
  562.     ; include-skip ist 1 bei type-option=T, 0 sonst.
  563.     (when (stringp (first docstring-and-slotargs))
  564.       (setq docstring (first docstring-and-slotargs))
  565.       (setq slotargs (rest docstring-and-slotargs))
  566.     ) ; sonst stimmen docstring und slotargs bereits.
  567.     ; docstring ist entweder NIL oder ein String.
  568.     ; slotargs sind die restlichen Argumente.
  569.     (if include-option
  570.       (let* ((option (rest include-option))
  571.              (subname (first option))
  572.              (incl-desc (get subname 'DEFSTRUCT-DESCRIPTION)))
  573.         (when (null incl-desc)
  574.           (error-of-type 'program-error
  575.             (DEUTSCH "~S ~S: Teilstruktur ~S ist nicht definiert."
  576.              ENGLISH "~S ~S: included structure ~S has not been defined."
  577.              FRANCAIS "~S ~S : La structure incluse ~S n'est pas dΘfinie.")
  578.             'defstruct name subname
  579.         ) )
  580.         (setq names (cons name (svref incl-desc 0)))
  581.         (setq namesbinding
  582.               (list
  583.                 (list
  584.                   (setq namesform (gensym))
  585.                   `(CONS ',name (LOAD-TIME-VALUE (SVREF (GET ',subname 'DEFSTRUCT-DESCRIPTION) 0)))
  586.         )     ) )
  587.         (unless (equalp (svref incl-desc 1) type-option)
  588.           (error-of-type 'program-error
  589.             (DEUTSCH "~S ~S: Teilstruktur ~S mu▀ vom selben Typ ~S sein."
  590.              ENGLISH "~S ~S: included structure ~S must be of the same type ~S."
  591.              FRANCAIS "~S ~S : La structure incluse ~S doit Ωtre du mΩme type ~S.")
  592.             'defstruct name subname type-option
  593.         ) )
  594.         (setq slotlist (nreverse (mapcar #'copy-ds-slot (svref incl-desc 3))))
  595.         ; slotlist ist die umgedrehte Liste der vererbten Slots
  596.         (when slotlist (setq include-skip (1+ (ds-slot-offset (first slotlist)))))
  597.         ; include-skip >=0 ist die Anzahl der bereits von der Teilstruktur
  598.         ;   verbrauchten Slots, das "size" der Teilstruktur.
  599.         ; Weitere Argumente der :INCLUDE-Option abarbeiten:
  600.         (dolist (slotarg (rest option))
  601.           (let* ((slotname (if (atom slotarg) slotarg (first slotarg)))
  602.                  (slot (find slotname slotlist :key #'ds-slot-name :test #'eq)))
  603.             (when (null slot)
  604.               (error-of-type 'program-error
  605.                 (DEUTSCH "~S ~S: Teilstruktur ~S hat keine Komponente namens ~S."
  606.                  ENGLISH "~S ~S: included structure ~S has no component with name ~S."
  607.                  FRANCAIS "~S ~S : La structure incluse ~S n'a pas de composante de nom ~S.")
  608.                 'defstruct name subname slotname
  609.             ) )
  610.             (if (atom slotarg)
  611.               (setf (ds-slot-default slot) 'NIL) ; Default auf NIL ⁿberschreiben
  612.               (progn
  613.                 (let ((default (second slotarg)))
  614.                   (unless (constantp default)
  615.                     (push
  616.                       `(FUNCTION ,(concat-pnames "DEFAULT-" slotname)
  617.                          (LAMBDA () ,default)
  618.                        )
  619.                       slotdefaultfuns
  620.                     )
  621.                     (setq default (gensym))
  622.                     (push default slotdefaultvars)
  623.                   )
  624.                   (setf (ds-slot-default slot) default)
  625.                 )
  626.                 ; slot-options dieses Slot-Specifier abarbeiten:
  627.                 (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr)))
  628.                     ((endp slot-arglistr))
  629.                   (let ((slot-keyword (first slot-arglistr))
  630.                         (slot-key-value (second slot-arglistr)))
  631.                     (cond ((eq slot-keyword ':READ-ONLY)
  632.                            (if slot-key-value
  633.                              (setf (ds-slot-readonly slot) t)
  634.                              (if (ds-slot-readonly slot)
  635.                                (error-of-type 'program-error
  636.                                  (DEUTSCH "~S ~S: Der READ-ONLY-Slot ~S von Teilstruktur ~S mu▀ auch in ~S READ-ONLY bleiben."
  637.                                   ENGLISH "~S ~S: The READ-ONLY slot ~S of the included structure ~S must remain READ-ONLY in ~S."
  638.                                   FRANCAIS "~S ~S : Le composant READ-ONLY ~S de la structure incluse ~S doit rester READ-ONLY dans ~S.")
  639.                                  'defstruct name slotname subname name
  640.                                )
  641.                                (setf (ds-slot-readonly slot) nil)
  642.                           )) )
  643.                           ((eq slot-keyword ':TYPE)
  644.                            (unless (subtypep slot-key-value (ds-slot-type slot))
  645.                              (error-of-type 'program-error
  646.                                (DEUTSCH "~S ~S: Der Typ ~S von Slot ~S mu▀ ein Untertyp des in Teilstruktur ~S definierten Typs ~S sein."
  647.                                 ENGLISH "~S ~S: The type ~S of slot ~S should be a subtype of the type defined for the included strucure ~S, namely ~S."
  648.                                 FRANCAIS "~S ~S : Le type ~S du composant ~S doit Ωtre un sous-type du type dΘfini dans la structure incluse ~S, c'est-α-dire ~S.")
  649.                                'defstruct name slot-key-value slotname subname (ds-slot-type slot)
  650.                            ) )
  651.                            (setf (ds-slot-type slot) slot-key-value)
  652.                           )
  653.                           (t (error-of-type 'program-error
  654.                                (DEUTSCH "~S ~S: ~S ist keine Slot-Option."
  655.                                 ENGLISH "~S ~S: ~S is not a slot option."
  656.                                 FRANCAIS "~S ~S : ~S n'est pas un option de composant.")
  657.                                'defstruct name slot-keyword
  658.                           )  )
  659.                 ) ) )
  660.         ) ) ) )
  661.         (when (eq (first include-option) ':INHERIT)
  662.           (setq inherited-slot-count (length slotlist))
  663.       ) )
  664.       (progn
  665.         (setq names (list name))
  666.         (setq namesform `',names)
  667.     ) )
  668.     ; names ist die Include-Verschachtelung, namesform die Form dazu.
  669.     ; slotlist ist die bisherige Slotliste, umgedreht.
  670.     ; inherited-slot-count ist die Anzahl der Slots, die beim Bilden der
  671.     ; Accessoren zu ignorieren sind.
  672.     (when (and named-option ; benannte Structure
  673.                (consp type-option) ; vom Typ (VECTOR ...)
  674.                ; mu▀ den/die Namen enthalten k÷nnen:
  675.                (not (typep names (second type-option)))
  676.           )
  677.       (error-of-type 'program-error
  678.         (DEUTSCH "~S ~S: Structure vom Typ ~S kann den Namen nicht enthalten."
  679.          ENGLISH "~S ~S: structure of type ~S can't hold the name."
  680.          FRANCAIS "~S ~S : Une structure de type ~S ne peut pas contenir le nom.")
  681.         'defstruct name type-option
  682.     ) )
  683.     ; Aufbau der Structure:
  684.     ; names, evtl. include-Slots, initial-offset-option mal NIL, Slots.
  685.     ; Aufbau von Vektor oder Liste:
  686.     ; include-Anteil, initial-offset-option mal NIL, evtl. Name, Slots.
  687.     (setq initial-offset (+ include-skip initial-offset-option))
  688.     (unless (eq type-option 'T)
  689.       (when named-option
  690.         (push
  691.           (make-ds-slot nil ; Kennzeichen fⁿr Typerkennungs-Slot
  692.                         '()
  693.                         (setq initial-offset-option initial-offset)
  694.                         (cons 'NIL name) name ; "Defaultwert" = name
  695.                         'SYMBOL ; Typ = Symbol
  696.                         T ; Read-Only
  697.           )
  698.           slotlist
  699.         )
  700.         (setq initial-offset (1+ initial-offset))
  701.     ) )
  702.     ; Die einzelnen Slots kommen ab initial-offset.
  703.     ; Bei type/=T (also Vektor oder Liste) und named-option sitzt
  704.     ;   der Name in Slot Nummer  initial-offset-option = (1- initial-offset).
  705.     ; Abarbeitung der einzelnen Slots:
  706.     (let ((offset initial-offset))
  707.       (dolist (slotarg slotargs)
  708.         (let (slotname
  709.               default)
  710.           (if (atom slotarg)
  711.             (setq slotname slotarg  default nil)
  712.             (setq slotname (first slotarg)  default (second slotarg))
  713.           )
  714.           (unless (constantp default)
  715.             (push
  716.               `(FUNCTION ,(concat-pnames "DEFAULT-" slotname)
  717.                  (LAMBDA () ,default)
  718.                )
  719.               slotdefaultfuns
  720.             )
  721.             (setq default (gensym))
  722.             (push default slotdefaultvars)
  723.           )
  724.           (when (find slotname slotlist :key #'ds-slot-name :test #'eq)
  725.             (error-of-type 'program-error
  726.               (DEUTSCH "~S ~S: Es kann nicht mehrere Slots mit demselben Namen ~S geben."
  727.                ENGLISH "~S ~S: There may be only one slot with the name ~S."
  728.                FRANCAIS "~S ~S : Il ne peut pas y avoir plusieurs composants avec le mΩme nom ~S.")
  729.               'defstruct name slotname
  730.           ) )
  731.           (let ((type t) (read-only nil))
  732.             (when (consp slotarg)
  733.               (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr)))
  734.                   ((endp slot-arglistr))
  735.                 (let ((slot-keyword (first slot-arglistr))
  736.                       (slot-key-value (second slot-arglistr)))
  737.                   (cond ((eq slot-keyword ':READ-ONLY)
  738.                          (setq read-only (if slot-key-value t nil))
  739.                         )
  740.                         ((eq slot-keyword ':TYPE) (setq type slot-key-value))
  741.                         (t (error-of-type 'program-error
  742.                              (DEUTSCH "~S ~S: ~S ist keine Slot-Option."
  743.                               ENGLISH "~S ~S: ~S is not a slot option."
  744.                               FRANCAIS "~S ~S : ~S n'est pas une option de composant.")
  745.                              'defstruct name slot-keyword
  746.                         )  )
  747.             ) ) ) )
  748.             (push (make-ds-slot slotname
  749.                                 (if slotname
  750.                                   (list (intern (symbol-name slotname) *keyword-package*))
  751.                                   '()
  752.                                 ) ; initargs
  753.                                 offset ; location
  754.                                 (if (constantp default)
  755.                                   (cons 'NIL (eval default)) ; default is a constant
  756.                                   (cons (add-unquote default) 'NIL) ; default is a gensym
  757.                                 )
  758.                                 default type read-only ; defstruct specific
  759.                   )
  760.               slotlist
  761.         ) ) )
  762.         (incf offset)
  763.       )
  764.       (setq size offset)
  765.     )
  766.     ; size = GesamtlΣnge der Structure
  767.     (setq slotlist (nreverse slotlist))
  768.     (setq slotdefaultfuns (nreverse slotdefaultfuns))
  769.     (setq slotdefaultvars (nreverse slotdefaultvars))
  770.     ; Die slots in slotlist sind jetzt wieder aufsteigend geordnet.
  771.     (setq constructor-forms
  772.       (mapcar
  773.         #'(lambda (constructor-option)
  774.             (if (consp constructor-option)
  775.               (ds-make-boa-constructor
  776.                 constructor-option type-option name namesform size slotlist
  777.               )
  778.               (progn
  779.                 (if (null keyword-constructor)
  780.                   (setq keyword-constructor constructor-option)
  781.                 )
  782.                 (ds-make-keyword-constructor
  783.                   constructor-option type-option name namesform size slotlist
  784.           ) ) ) )
  785.         constructor-option-list
  786.     ) )
  787.     ; constructor-forms = Liste der Formen, die die Konstruktoren definieren.
  788.     (let ((index 4))
  789.       (dolist (defaultvar slotdefaultvars)
  790.         (setf (ds-slot-default (find defaultvar slotlist :key #'(lambda (x) (ds-slot-default x)) :test #'eq))
  791.               `(SVREF (GET ',name 'DEFSTRUCT-DESCRIPTION) ,index)
  792.         )
  793.         (incf index)
  794.     ) )
  795.     ; slotlist enthΣlt nun keine der slotdefaultvars mehr.
  796.     `(EVAL-WHEN (LOAD COMPILE EVAL)
  797.        (LET ()
  798.          (LET ,(append namesbinding (mapcar #'list slotdefaultvars slotdefaultfuns))
  799.            ,@constructor-forms
  800.            (%PUT ',name 'DEFSTRUCT-DESCRIPTION
  801.                  (VECTOR ,namesform ',type-option ',keyword-constructor
  802.                          ,(add-backquote slotlist)
  803.                          ,@slotdefaultvars
  804.          ) )     )
  805.          ,@(if (eq type-option 'T) `((CLOS::DEFINE-STRUCTURE-CLASS ',name)))
  806.          ,@(if (and named-option predicate-option)
  807.              (ds-make-pred predicate-option type-option name initial-offset-option)
  808.            )
  809.          ,@(if copier-option (ds-make-copier copier-option name type-option))
  810.          ,@(let ((directslotlist (nthcdr inherited-slot-count slotlist)))
  811.              `(,@(ds-make-accessors name type-option conc-name-option directslotlist)
  812.                ,@(ds-make-defsetfs name type-option conc-name-option directslotlist)
  813.               )
  814.            )
  815.          (SETF (DOCUMENTATION ',name 'STRUCTURE) ,docstring)
  816.          ,(if print-function-option
  817.             `(%PUT ',name 'STRUCTURE-PRINT ,print-function-option)
  818.             `(REMPROP ',name 'STRUCTURE-PRINT)
  819.           )
  820.          ',name
  821.      ) )
  822. ) )
  823.  
  824.